home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / Modes / Perl Mode / perl5.tcl < prev    next >
Encoding:
Text File  |  1997-10-08  |  8.0 KB  |  241 lines  |  [TEXT/ALFA]
  1. proc perl5.tcl {} {}
  2.  
  3. ##############################################################################
  4. # Colorization and cmd-dbl-click support for Perl 5
  5. #
  6. # Author: Tom Pollard <pollard@chem.columbia.edu>
  7. # Last modified: 1/1/96
  8. #
  9. # if {![info exists perlDocs]} {
  10. #     set perlDocs "$HOME:Help:Perl Docs"
  11. # }
  12.  
  13. ##############################################################################
  14. # Colorization setup
  15. #
  16. # Keywords are separated here according to their location in the Perl 5
  17. # documentation for the convenience of the cmd-double-click mechanism.
  18. #
  19. set perlKeyWords {}
  20.  
  21. # These are described in the "Compound statements" section of "perlsyn"
  22. #
  23. set words {  
  24.     continue else elsif for foreach if return unless until while 
  25.     eq ne cmp lt gt le ge
  26. }
  27. foreach wd $words { 
  28.     set perlLookup($wd) [list perlsyn {Compound statements}] 
  29. }
  30. set perlKeyWords [concat $perlKeyWords $words]
  31.  
  32. # These are described in the "SYNOPSIS" section of "perlsub"
  33. #
  34. set words { sub }
  35. foreach wd $words { set perlLookup($wd) [list perlsub {SYNOPSIS}] }
  36. set perlKeyWords [concat $perlKeyWords $words]
  37.  
  38. # These are described in the "Packages" section of "perlmod"
  39. #
  40. set words { package }
  41. foreach wd $words { set perlLookup($wd) [list perlmod {Packages}] }
  42. set perlKeyWords [concat $perlKeyWords $words]
  43.  
  44. # These are described in the "Package Constructors and Destructors" 
  45. # section of "perlmod" and can't be colorized.
  46. #
  47. set words { BEGIN END }
  48. foreach wd $words { 
  49.     set perlLookup($wd) [list perlmod {Package Constructors and Destructors}] 
  50. }
  51.  
  52. # These are described in the "A Class is Simply a Package" 
  53. # section of "perlobj" and can't be colorized.
  54. #
  55. set words { @ISA $ISA }
  56. foreach wd $words { 
  57.     set perlLookup($wd) [list perlobj {A Class is Simply a Package}] 
  58. }
  59.  
  60. # These are described in the "SYNOPSIS" section of "perlovl" and 
  61. # can't be colorized.
  62. #
  63. set words { %OVERLOAD $OVERLOAD }
  64. foreach wd $words { set perlLookup($wd) [list perlovl {SYNOPSIS}] }
  65.  
  66. # Special variables are described in "perlvar" (and are not all
  67. # individually marked, so we have to search for them.)
  68. #
  69. # This group can safely be colorized...
  70. #
  71. set words {
  72.     $_ $1 $2 $3 $4 $5 $6 $7 $8 $9 $& $` $' $+ $* $.  $/ $| $, $\\ $" $; $# $% 
  73.     $= $- $~ $^ $: $?  $!  $@ $$ $< $> $( $) $0 $[ $]
  74. }
  75. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  76. set perlKeyWords [concat $perlKeyWords $words]
  77.  
  78. #... while this group is forced lower-case by the current colorization scheme
  79. #
  80. set words {
  81.     $ARG $MATCH $PREMATCH $POSTMATCH $LAST_PAREN_MATCH $MULTILINE_MATCHING 
  82.     $INPUT_LINE_NUMBER $NR $INPUT_RECORD_SEPARATOR $RS $OUTPUT_AUTOFLUSH 
  83.     $OUTPUT_FIELD_SEPARATOR $OFS $OUTPUT_RECORD_SEPARATOR $ORS 
  84.     $LIST_SEPARATOR $SUBSCRIPT_SEPARATOR $SUBSEP $OFMT $FORMAT_PAGE_NUMBER 
  85.     $FORMAT_LINES_PER_PAGE $FORMAT_LINES_LEFT $FORMAT_NAME $FORMAT_TOP_NAME 
  86.     $FORMAT_LINE_BREAK_CHARACTERS $FORMAT_FORMFEED $^L $ACCUMULATOR $^A 
  87.     $CHILD_ERROR $OS_ERROR $ERRNO $EVAL_ERROR $PROCESS_ID $PID $REAL_USER_ID 
  88.     $UID $EFFECTIVE_USER_ID $EUID $REAL_GROUP_ID $GID $EFFECTIVE_GROUP_ID 
  89.     $EGID $PROGRAM_NAME $PERL_VERSION $DEBUGGING $^D $SYSTEM_FD_MAX $^F 
  90.     $INPLACE_EDIT $^I $PERLDB $^P $BASETIME $^T $WARNING $^W 
  91.     $EXECUTABLE_NAME $^X $ARGV @ARGV @INC %INC $INC $ENV $SIG %ENV %SIG
  92. }
  93. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  94.  
  95. # These are also described in "perlvar", despite being functions.
  96. #
  97. set words {
  98.     input_line_number input_record_separator autoflush 
  99.     output_field_separator output_record_separator format_page_number 
  100.     format_lines_per_page format_lines_left format_name format_top_name 
  101.     format_line_break_characters format_formfeed
  102. }
  103. foreach wd $words { set perlLookup($wd) [list perlvar $wd] }
  104. set perlKeyWords [concat $perlKeyWords $words]
  105.  
  106.  
  107. # These are described in "perlfunc"
  108. #
  109. set words {
  110.     abs accept alarm atan2 bind binmode bless caller chdir chmod chomp 
  111.     chop chown chr chroot close closedir connect cos crypt dbmclose dbmopen 
  112.     defined delete die do dump each eof eval exec exists exit exp fcntl 
  113.     fileno flock fork formline getc getlogin getpeername getpgrp getppid 
  114.     getpriority getpwnam getgrnam gethostbyname getnetbyname getprotobyname 
  115.     getpwuid getgrgid getservbyname gethostbyaddr getnetbyaddr 
  116.     getprotobynumber getservbyport getpwent getgrent gethostent getnetent 
  117.     getprotoent getservent setpwent setgrent sethostent setnetent 
  118.     setprotoent setservent endpwent endgrent endhostent endnetent 
  119.     endprotoent endservent getsockname getsockopt glob gmtime goto grep hex 
  120.     import index int ioctl join keys kill last lc lcfirst length link listen 
  121.     local localtime log lstat m map mkdir msgctl msgget msgsnd msgrcv my 
  122.     next no oct open opendir ord pack pipe pop pos print printf push q qq qx 
  123.     qw quotemeta rand rand read readdir readlink recv redo ref rename 
  124.     require reset return reverse rewinddir rindex rmdir s scalar seek 
  125.     seekdir select select semctl semget semop send setpgrp setpriority 
  126.     setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep 
  127.     socket socketpair sort splice split sprintf sqrt srand stat study substr 
  128.     symlink syscall sysread system syswrite tell telldir tie time times tr 
  129.     truncate uc ucfirst umask undef unlink unpack untie unshift use utime 
  130.     values vec wait waitpid wantarray warn write y
  131. }
  132. foreach wd $words { set perlLookup($wd) [list perlfunc $wd] }
  133. set perlKeyWords [concat $perlKeyWords $words]
  134.  
  135. regModeKeywords -e {#} -c red -k blue -s [set PerlmodeVars(stringColor)] Perl $perlKeyWords
  136. unset perlKeyWords
  137.  
  138. set perlKeyWords [array names perlLookup]
  139.  
  140. ##############################################################################
  141. # Cmd-double-click support for Perl mode. (modified for Perl 5 doc structure)
  142. # 
  143. proc Perl::DblClick {from to} {
  144.     global HOME perlKeyWords perlLookup perlDocs perlVersion
  145.     global perlSearchPath
  146.     
  147.     set pc  [lookAt [expr $from - 1]]
  148.     set ppc [lookAt [expr $from - 2]]
  149.     set tc  [lookAt $to]
  150.     
  151.     # Extend selection to include special characters
  152.     #
  153.     if {$pc == {$}} { 
  154.         if {$from == $to} { incr to }
  155.         incr from -1
  156.         if {$tc == {^}} { incr to }
  157.         
  158.     } elseif {$pc == {^} && $ppc == {$}} {
  159.         incr from -2
  160.         
  161.     } elseif {$pc == {%} || $pc == {@}} {
  162.         incr from -1
  163.     }
  164.     
  165.     # Return if there's no selected text
  166.     if {$to > $from} {
  167.         select $from $to
  168.         set text [getSelect]
  169.         set qtext [quoteExpr $text]
  170.     } else {
  171.         return
  172.     }
  173. #     alertnote "\"$text\""
  174.  
  175.     set perlSearchPath {}
  176.  
  177.     # Function call
  178.     if {$pc == "&"} {
  179.          if {![catch {search -f 1 -r 1 -m 0 -s "sub *$qtext *\{" 0} mtch]} {
  180.              pushPosition
  181.              eval select $mtch
  182.              message "Use Ctl-. to return to original position"
  183.          } else {
  184.              message {Sub definition not found}
  185.          }
  186.  
  187.     # Look up keywords in the man page by their file marks
  188.     } elseif {[lsearch -exact $perlKeyWords $text] >= 0} {
  189.         set file [lindex $perlLookup($text) 0]
  190.         set mark [lindex $perlLookup($text) 1]
  191.         openFileQuietly "$perlDocs:$file"
  192.         podFindMark "$mark"
  193.     
  194.     # If user clicked the arg of a 'require' command, open the file
  195.     } elseif {![catch {perlFindRequire $from $to} filename]} {
  196.         openPerlFile $filename
  197.  
  198.     # Other
  199.     } else {
  200.         select $from $to
  201.         message {Command-double-click on keywords, special vars, and req'd filenames}
  202.     }
  203.  
  204. }
  205.  
  206. #############################################################################
  207. # These last two procs are duplicated from "pod.tcl", so that that file 
  208. # doesn't have to be loaded in order simply to reference the Perl 5 docs
  209. #
  210. proc podFindMark {mark} {
  211.     global podMarkIndent
  212.     set mark0 $mark
  213.     set marks [getNamedMarks -n]
  214.     regsub -all {[\/\(\)<>^]} $mark { } mark
  215.     set mark [quote::Insert $mark]
  216.     set item [lsearch -regexp $marks " *${mark}"]
  217.     if {$item >= 0} {
  218.         gotoMark [lindex $marks $item]
  219.     } elseif {![catch {search -f 1 -r 1 -i 0 -m 0 -s " *${mark}" 0} mtch]} {
  220.             goto [lindex $mtch 0]
  221.     } else {
  222.         message "Couldn't locate the section for \"$mark0\""
  223.     } 
  224. }
  225.  
  226. proc quote::Insert str {
  227.     regsub -all {\\} $str {\\\\} str
  228.     regsub -all {\|} $str {\|} str
  229.     regsub -all {\*} $str {\\*} str
  230.     regsub -all {\+} $str {\\+} str
  231.     regsub -all {\?} $str {\\?} str
  232.     regsub -all {\$} $str {\\$} str
  233.     regsub -all {\(} $str {\\(} str
  234.     regsub -all {\)} $str {\\)} str
  235.     regsub -all {\{} $str "\\\{" str
  236.     regsub -all {\}} $str "\\\}" str
  237.     regsub -all {\[} $str {\\[} str
  238.     regsub -all {\]} $str {\\]} str
  239.     return $str
  240. }
  241.